perm filename NILAID.LSP[MAC,LSP] blob
sn#451461 filedate 1979-06-22 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00008 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 NILAID -*-LISP-*-
C00006 00003
C00009 00004
C00012 00005
C00015 00006
C00016 00007
C00020 00008
C00024 ENDMK
C⊗;
;;; NILAID -*-LISP-*-
;;; Support routines which help maclisp to run NIL-like code.
;;; Current features translated, and limitations:
;;; Vector and sequence manipulations
;;; VECTORs translate into HUNKs
;;; macros: VREF, VSET, MAKE-VECTOR, VECTOR, VECTOR-LENGTH
;;; subroutines: VECTORP, LIST-VECTOR, ELT, SETELT, REPLACE, POSASSQ
;;; LISTs
;;; macros: LIST-LENGTH, NNLISTP, PAIRP
;;; String and Character manipulations
;;; STRINGs translate into SYMBOLs
;;; CHARACTERs translate into SYMBOLs
;;; subroutines: STRING-APPEND
;;; macros: STRINGP, CHARACTERP, GET-PNAME
;;; Misc.
;;; macros: FIXNUMP, >=, <=, PSETQ, TYPECASEQ
(defun cmptime-eval macro (x) (and (eval (cadr x)) (eval (caddr x))))
(cmptime-eval (status feature maclisp)
`(OR (STATUS FEATURE NOLDMSG)
(PRINC ',(implode (nconc (exploden '|/
Loading NILAID |)
(do ((x (exploden
(cond ((caddr (truename infile)))
('/12)))
(cdr x)))
((lessp 47. (car x) 58.)
x))
(exploden '| |))))))
(eval-when (eval compile load)
(cmptime-eval 't
(let ((file (cond ((status feature its)
'(|dsk:liblsp;abbrev fasl| |dsk:liblsp;nilaid fasl|))
((status feature dec20)
'(|ps:<maclisp>abbrev.fasl| |ps:<maclisp>nilaid.fasl|))
((status feature sail)
'(|dsk:[mac,lsp]abbrev.fas| |dsk:[mac,lsp]nilaid.fas|))
((status feature dec10)
'( ((lisp) abbrev fas) ((lisp) nilaid fas) ))
((status feature lispm)
(cond ((or (not (fboundp 'vref)) ;No AUTOLOAD on LISPM?
(atom (fsymeval 'vref))
(not (eq (car (fsymeval 'vref)) 'MACRO)))
(load '|ai:lispm2;abbrev qfasl|)))
'(|ai:lispm2;abbrev qfasl| |ai:lispm2;nilaid qfasl|)))))
`(PROGN 'COMPILE
(DEFPROP ABBREVIATION ,(car file) AUTOLOAD)
(DEFPROP ABBREVIATION-DISPLACE ,(car file) AUTOLOAD)
(DEFPROP MACROEXPAND ,(get 'defun/& 'autoload) AUTOLOAD)
(DEFPROP |no-funp/|| ,(cadr file) AUTOLOAD)
(DEFPROP |side-effectsp/|| ,(cadr file) AUTOLOAD)))
))
(eval-when (eval compile)
(defun (IF-MACLISP macro) (x)
(and (status feature MACLISP)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NOT-MACLISP macro) (x)
(and (not (status feature MACLISP))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-LISPM macro) (x)
(and (status feature LISPM)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NOT-LISPM macro) (x)
(and (not (status feature LISPM))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NIL macro) (x)
(and (status feature NIL)
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NILNIL macro) (x)
(and (status feature NIL)
(not (status feature ITS))
`(PROGN 'COMPILE ,@(cdr x))))
(defun (IF-NILINT macro) (x)
(and (status feature NIL)
(status feature ITS)
`(PROGN 'COMPILE ,@(cdr x))))
)
(DECLARE (*LEXPR STRING-APPEND REPLACE))
(EVAL-WHEN (COMPILE)
(SETQ DEFMACRO-CHECK-ARGS ()
DEFMACRO-DISPLACE-CALL 'T
DEFMACRO-FOR-COMPILING 'T))
;;; Many functions of one argument can be macro-expanded, providing
;;; that the argument-form can be multiplied. If not, then we must
;;; wrap a LAMBDA around it, and give it an argument-form of a symbol.
(DEFMACRO (DEFSIMPLEMAC DEFMACRO-FOR-COMPILING () ) (NAME VARS &REST BODY)
(AND (OR (ATOM VARS) (NOT (SYMBOLP (CAR VARS))) (CDR VARS))
(ERROR '|Bad arglist for DEFSIMPLEMAC| `(,name ,vars ,@body)))
`(DEFMACRO ,name ,vars
(COND ((|no-funp/|| ,(car vars))
,(cond ((cdr body) '(cons 'PROGN body))
((car body))))
((LET ((G (GENSYM)))
`((LAMBDA (,g) (,',name ,g)) ,,(car vars)))))))
(ABBREVIATION LIST-LENGTH LENGTH)
(DEFSIMPLEMAC NNLISTP (X) `(AND ,x (NOT (ATOM ,x))))
(DEFSIMPLEMAC PAIRP (X) `(AND ,x (NOT (ATOM ,x))))
(DEFSIMPLEMAC CHARACTERP (X) `(AND (SYMBOLP ,x) (= (FLATC ,x) 1) ,x))
(DEFMACRO FIXNUMP (X) `(EQ (TYPEP ,x) 'FIXNUM))
(DEFMACRO <= (X Y) `(NOT (> ,x ,y)))
(DEFMACRO >= (X Y) `(NOT (< ,x ,y)))
(DEFMACRO TYPECASEQ (X &REST Y) `(CASEQ (TYPEP ,x) . ,y))
(IF-MACLISP
(ABBREVIATION VECTORP HUNKP VECTOR-LENGTH HUNKSIZE)
(DEFUN MAKE-VECTOR (N)
(DECLARE (FIXNUM N))
(LET ((DEADSLOT (MUNKAM 777777)) X)
(CASEQ N
(0 () )
(1 (SETQ X (MAKHUNK 3))
(RPLACX 2 X DEADSLOT)
(RPLACX 1 X DEADSLOT))
(2 (SETQ X (MAKHUNK 3))
(RPLACX 2 X DEADSLOT))
(T (MAKHUNK N)))))
(DEFMACRO VECTOR X
(COND ((NULL X) () )
((NULL (CDR X)) `(RPLACD (MAKE-VECTOR 1) ,(car x)))
((NULL (CDDR X))
`(RPLACX 2 (VECTOR ,(car x) ,(cadr x) () ) (MUNKAM 777777)))
((COND ((ATOM (CAR X)) (NOT (SYMBOLP (CAR X))))
((MEMQ (CAAR X) '(QUOTE FUNCTION)))
((NULL (MAPCAN '|side-effectsp/|| (CDR X)))))
(CONS 'HUNK (NREVERSE (CONS (CAR X) (REVERSE (CDR X))))))
((LET ( (FIRST (CAR X)) (G (GENSYM)) )
(SETQ X (NREVERSE (CONS () (REVERSE (CDR X)))))
`((LAMBDA (,g) (RPLACD (HUNK . ,x) ,g)) ,first)))))
;;; Remember! this is within a IF-MACLISP
(DEFMACRO VREF (H N)
(COND ((AND (NOT (MEMQ H '(T NIL)))
(NOT (NUMBERP H))
(NOT (HUNKP H))
(NOT (EQ (TYPEP H) 'ARRAY))
(NOT (AND (NOT (ATOM H)) (EQ (CAR H) 'QUOTE)))
(OR (|side-effectsp/|| N)
(|side-effectsp/|| H)))
`((LAMBDA (H N) (CXR N H)) ,h ,n))
(`(CXR ,n ,h))))
(DEFMACRO VSET (H N VAL)
(COND ((AND (NOT (MEMQ H '(T NIL)))
(NOT (NUMBERP H))
(NOT (HUNKP H))
(NOT (EQ (TYPEP H) 'ARRAY))
(NOT (AND (NOT (ATOM H)) (EQ (CAR H) 'QUOTE)))
(OR (|side-effectsp/|| N)
(|side-effectsp/|| H)))
`((LAMBDA (H N VAL) (RPLACX N H VAL))
,h ,n ,val))
(`(RPLACX ,n ,h ,val))))
(ABBREVIATION STRINGP SYMBOLP)
(DEFUN |+internal-doublequote-macro/|| ()
(DO ( (C (TYI) (TYI)) (L) )
( (= C 34.) (IMPLODE (NREVERSE L)) ) ;check for final "
(DECLARE (FIXNUM C))
(PUSH (COND ((= C 47.) (SETQ C -1) (TYI))
(C))
L)))
(setsyntax '/" 'macro '|+internal-doublequote-macro/||)
(DEFSIMPLEMAC GET-PNAME (X) `(AND (SYMBOLP ,x) ,x))
(DEFUN STRING-APPEND N (IMPLODE (MAPCAN 'EXPLODEN (LISTIFY N))))
(DEFMACRO PSETQ (SYM VAL &REST W)
`(SETQ ,sym ,(cond ((null w) val)
(`(PROG2 () ,val (PSETQ . ,w))))))
)
(IF-LISPM
(DEFMACRO MAKE-VECTOR (X) `(MAKE-ARRAY () 'ART-Q ,x))
(DEFMACRO VECTOR-LENGTH (X) `(ARRAY-DIMENSION-N 1 ,x))
(DEFMACRO VECTOR X
`(FILLARRAY (MAKE-ARRAY () 'ART-Q ,(length x)) (LIST . ,x)))
(ABBREVIATION VREF AREF)
(DEFMACRO VSET (H N VAL)
(COND ((AND (NOT (MEMQ VAL '(T NIL)))
(NOT (NUMBERP VAL))
(NOT (ARRAYP VAL))
(NOT (AND (LISTP VAL) (EQ (CAR VAL) 'QUOTE)))
(OR (|side-effectsp/|| N)
(|side-effectsp/|| H)
(|side-effectsp/|| VAL)))
`((LAMBDA (H N VAL) (ASET VAL H N))
,h ,n ,val))
(`(ASET ,val ,h ,n))))
)
(IF-LISPM
(DEFUN VECTORP (X)
(AND (ARRAYP )
(EQ (ARRAY-TYPE X) 'ART-Q)
(= (ARRAY-/#-DIMS X) 1)))
)
(DEFUN ELT (V I)
(COND ((VECTORP V) (VREF V I))
((NOT (ATOM V)) (NTH I V))
((SYMBOLP V) (GETCHAR V (1+ I)))))
(DEFUN SETELT (V I X)
(COND ((VECTORP V) (VSET V I X))
((LET (TEM)
(COND ((AND (NNLISTP V) (SETQ TEM (NTHCDR I V)))
(RPLACA TEM X))
('T (SETQ V (ERROR '|Improper sequence for SETELT|
V
'WRNG-TYPE-ARG))
(SETELT V I X)))))))
(DEFUN REPLACE (V1 V2 /&OPTIONAL (I1 0) (I2 0) CNTR
/&AUX (VP1 (VECTORP V1))
(VP2 (VECTORP V2))
(L1 (COND (VP1 (VECTOR-LENGTH V1))
((NOT (ATOM V1)) (LIST-LENGTH V1))
(-1)))
(L2 (COND (VP2 (VECTOR-LENGTH V2))
((NOT (ATOM V2)) (LIST-LENGTH V2))
(-1)))
(ANS V1)
(OCNTR CNTR) )
(DECLARE (FIXNUM I1 I2 I IX1 IX2))
(AND (NULL CNTR)
(> (SETQ CNTR (- L2 I2)) (- L1 I1))
(SETQ CNTR (- L1 I1)))
(AND (OR (> (+ I1 CNTR) L1) (> (+ I2 CNTR) L2))
(ERROR '|Bad args to REPLACE| (LIST V1 V2 I1 I2 OCNTR)))
(AND (NOT VP1) (SETQ V1 (NTHCDR I1 V1)))
(AND (NOT VP2) (SETQ V2 (NTHCDR I2 V2)))
(COND (VP1 (DO ( (I CNTR (1- I))
(IX1 I1 (1+ IX1))
(IX2 I2 (1+ IX2)))
( (<= I 0) () )
(VSET V1 IX1 (COND (VP2 (VREF V2 IX2))
('T (POP V2))))))
('T (DO ( (I CNTR (1- I)) (IX2 I2 (1+ IX2)) )
( (<= I 0) () )
(RPLACA V1 (COND (VP2 (VREF V2 IX2))
('T (POP V2)) ))
(POP V1))))
ANS)
(DEFUN POSASSQ (X V)
(DECLARE (FIXNUM N))
(COND ((VECTORP V)
(LET ((N (VECTOR-LENGTH V)) G)
(DO I 0 (1+ I) (>= I N)
(AND (NOT (ATOM (SETQ G (VREF V I))))
(EQ (CAR G) X)
(RETURN I)))))
((NOT (ATOM V))
(LET ((N (LIST-LENGTH V)) (G (ASSQ X V)))
(COND ((NULL G) ())
((- N (LIST-LENGTH (MEMQ G V)))))))
((ERROR '|Bad args to POSASSQ| (LIST X V)))))
(DEFUN |+internal-tilde-macro/|| ()
(LET ((C (TYI)))
(DECLARE (FIXNUM C))
(COND ((= C 47.) (READCH)) ;check for slash
((ASCII C)))))
(setsyntax '/} 'macro '|+internal-tilde-macro/||)
(IF-MACLISP
(setsyntax '/. (boole 4 (status syntax /.) 1←17.) () )
)
(DEFUN |no-funp/|| (X)
(COND ((OR (ATOM X) (MEMQ (CAR X) '(QUOTE FUNCTION DECLARE))))
((NOT (ATOM (CAR X))) () )
((|carcdrp/|| (CAR X)) (|no-funp/|| (CADR X))) ))
(DEFUN |side-effectsp/|| (X)
(COND ((ATOM X) () )
((MEMQ (CAR X) '(QUOTE FUNCTION DECLARE)) () )
((AND (NOT (ATOM (CAR X)))
(EQ (CAAR X) 'LAMBDA))
(OR (MAPCAN '|side-effectsp/|| (CDDAR X))
(MAPCAN '|side-effectsp/|| (CDR X))))
((OR (NOT (SYMBOLP (CAR X))) (GET (CAR X) 'FSUBR)) (LIST 'T))
((|carcdrp/|| (CAR X)) (|side-effectsp/|| (CADR X)))
((OR (MEMQ (CAR X) '(CONS NCONS XCONS ASSQ ASSOC COPYSYMBOL GET GETL
GETCHAR GETCHARN IMPLODE LAST LIST LISTIFY PNGET
EXPLODE EXPLODEC EXPLODEN FLATC FLATSIZE INTERN
HUNK LISTARRAY MAKHUNK MAKNAM PLIST
MEMQ MEMBER SUBLIS SUBST REVERSE APPEND
BIGP EQUAL EQ FIXP FLOATP NUMBERP SYMBOLP TYPEP
NOT NULL ODDP GREATERP LESSP PLUSP MINUSP ZEROP
FILEP FASLP PROBEF NAMELIST NAMESTRING TRUENAME
))
(MEMQ (CAR X) '(PLUS DIFFERENCE TIMES QUOTIENT ADD1 SUB1 ABS
+ - * // 1+ 1- ↑ +$ -$ *$ //$ 1+$ 1-$ ↑$
\ \\ REMAINDER GCD EXP EXPT BOOLE > < =
IFIX FIX LOG SQRT SIN COS ROT LSH FSC
HAIPART HAULONG HUNKSIZE LENGTH SXHASH
))
(MEMQ (CAR X) '(ELT VREF VECTORP VECTOR MAKE-VECTOR VECTOR-LENGTH
>= <= FIXNUMP LIST-LENGTH NNLISTP CHARACTERP
GET-PNAME STRING-APPEND STRINGP STRING-LENGTH
)))
(MAPCAN '|side-effectsp/|| (CDR X)))
((LET* ( (OCARX (CAR X)) (OCDRX (CDR X)) (Y (MACROEXPAND X)) )
(COND ((AND (EQ X Y) (EQ OCARX (CAR Y)) (EQ OCDRX (CDR Y)))
(LIST 'T))
((|side-effectsp/|| Y)))))))
(DEFUN |carcdrp/|| (X)
(AND (SYMBOLP X)
(LET ( (N (FLATC X)) )
(DECLARE (FIXNUM N))
(COND ((OR (NOT (LESSP 2 N 7))
(NOT (EQ (GETCHAR X 1) 'C))
(NOT (EQ (GETCHAR X N) 'R)))
() )
((PROG (TMP)
A (AND (< (SETQ N (1- N)) 2) (RETURN 'T))
(SETQ TMP (GETCHAR X N))
(AND (NOT (MEMQ TMP '(A D))) (RETURN () ))
(GO A)))))))